Chapter 9

Code example 9-1
Private Sub AddDAR_Click()
'Moves to new empty form.
On Error GoTo Err_AddDAR_Click
    DoCmd.GoToRecord , , acNewRec
Exit_AddDAR_Click:
    Exit Sub
Err_AddDAR_Click:
    MsgBox Err.Description
    Resume Exit_AddDAR_Click
End Sub
Private Sub CloseDAR_Click()
'Closes DARs form.
On Error GoTo Err_CloseDAR_Click
    DoCmd.Close
Exit_CloseDAR_Click:
    Exit Sub
Err_CloseDAR_Click:
    MsgBox Err.Description
    Resume Exit_CloseDAR_Click 
End Sub
Private Sub PrintDAR_Click()
'Prints the current DAR form
On Error GoTo Err_PrintDAR_Click
    DoCmd.DoMenuItem acFormBar, acEditMenu, 8, , acMenuVer70
    DoCmd.PrintOut acSelection
Exit_PrintDAR_Click:
    Exit Sub
Err_PrintDAR_Click:
    MsgBox Err.Description
    Resume Exit_PrintDAR_Click
End Sub
Code example 9-2
Private Sub Report_Open(Cancel As Integer)
'A Delete query removes all records from the CdHrs table then
'Populates the CdHrs table using a series of append queries.
'The seven append queries place the seven sets of Activity Codes
'and corresponding Hours from the DAR into a single table.

Dim strSQL As String
'The next statement turns off the warning messages.
DoCmd.SetWarnings False

'The query deletes all records from the CdHrs table.
strSQL = "DELETE CdHrs.* FROM CdHrs;"
DoCmd.RunSQL strSQL

'The next seven append queries populate the CdHrs table.
strSQL = "INSERT INTO CdHrs ( DARDate, Code, Hours ) " & _
    "SELECT DARs.DARDate, DARs.Code1, DARs.Hours1" & _
    "FROM DARs " & _
    "WHERE (((DARs.Hours1)<>0));"
DoCmd.RunSQL strSQL
strSQL = "INSERT INTO CdHrs ( DARDate, Code, Hours )" & _
    "SELECT DARs.DARDate, DARs.Code2, DARs.Hours2 " & _
    "FROM DARs WHERE (((DARs.Hours2)<>0));"
DoCmd.RunSQL strSQL

strSQL = "INSERT INTO CdHrs ( DARDate, Code, Hours )" & _
    "SELECT DARs.DARDate, DARs.Code3, DARs.Hours3 " & _
    "FROM DARs WHERE (((DARs.Hours3)<>0));"
DoCmd.RunSQL strSQL

strSQL = "INSERT INTO CdHrs ( DARDate, Code, Hours )" & _
    "SELECT DARs.DARDate, DARs.Code4, DARs.Hours4 " & _
    "FROM DARs WHERE (((DARs.Hours4)<>0));"
DoCmd.RunSQL strSQL

strSQL = "INSERT INTO CdHrs ( DARDate, Code, Hours )" & _
    "SELECT DARs.DARDate, DARs.Code5, DARs.Hours5 " & _
    "FROM DARs WHERE (((DARs.Hours5)<>0));"
DoCmd.RunSQL strSQL

strSQL = "INSERT INTO CdHrs ( DARDate, Code, Hours )" & _
    "SELECT DARs.DARDate, DARs.Code6, DARs.Hours6 " & _
    "FROM DARs WHERE (((DARs.Hours6)<>0));"
DoCmd.RunSQL strSQL

strSQL = "INSERT INTO CdHrs ( DARDate, Code, Hours )" & _
    "SELECT DARs.DARDate, DARs.Code7, DARs.Hours7 " & _
    "FROM DARs WHERE (((DARs.Hours7)<>0));"
DoCmd.RunSQL strSQL

DoCmd.SetWarnings True
End Sub
Code example 9-3
Private Sub Form_Open(Cancel As Integer)
DoCmd.Maximize
DoCmd.GoToRecord acDataForm, "DARs", acGoTo, 10
Forms("DARs").Controls("ID#").StatusBarText = _
    "Choose the Sr Vol# and the LastName will fill in automatically"
End Sub
Code example 9-4
Public Sub Host()
    CountTo 10
    AllDone
End Sub

Public Sub CountTo(Limit)
Dim intCount As Integer
Dim intTotal As Integer
intTotal = 0
For intCount = 1 To Limit
    intTotal = intTotal + 1
Next intCount
MsgBox intTotal    'Displays the final count, 10.
End Sub

Public Sub AllDone()
MsgBox "Ran through all loops"
End Sub
Code example 9-5
Sub NewTblDef()

Dim dbsDFG11 As Database
Dim tdfNewTbl As TableDef
Dim idxNew As Index

Set dbsDFG11 = CurrentDb

'Build a new table definition.
Set tdfNewTbl = dbsDFG11.CreateTableDef("Regions")

With tdfNewTbl
    'Define the table fields and add them to the new table.
    .Fields.Append .CreateField("RegionNo", dbLong, 20)
    .Fields.Append .CreateField("Region", dbText, 25)
    .Fields.Append .CreateField("Title", dbText, 20)
    .Fields.Append .CreateField("Manager", dbText, 20)
    .Fields.Append .CreateField("Phone", dbText, 20)
    .Fields.Append .CreateField("Range", dbMemo)
    
     'Create new index object and add to the Indexes collection.
    Set idxNew = .CreateIndex("RegNoIndex")
    idxNew.Fields.Append idxNew.CreateField("RegionNo", dbLong, 2)
    idxNew.Primary = True
    .Indexes.Append idxNew
  
End With

'Append the new Regions table to the DFG11 database.
dbsDFG11.TableDefs.Append tdfNewTbl
End Sub
Code example 9-6
Sub NewQryDef()
Dim dbsDFG11 As Database
Dim qdfE-mail As QueryDef
Dim rstTemp As Recordset

Set dbsDFG11 = CurrentDb
With dbsDFG11
    'Create a new query definition.
    Set qdfE-mail = .CreateQueryDef("GetE-mailList", _
        "SELECT * FROM SrVols WHERE e-mail Is Not Null")

    'Open recordset and print report.
    With qdfE-mail
        Debug.Print .Name
        Debug.Print "  " & .SQL
        Set rstTemp = .OpenRecordset(dbOpenSnapshot)
        With rstTemp
            .MoveLast
            Debug.Print " Number of records = " & .RecordCount
            Debug.Print
            .Close
        End With
    End With
    End With
End Sub
Code example 9-7
Public Sub NewIndex()
Dim dbsDFG As Database
Dim tdfVols As TableDef
Dim idxCity As Index, idxZipCode As Index

Set dbsDFG = CurrentDb
Set tdfVols = dbsDFG!SrVols

With tdfVols
    'Create an index object then add fields to it.
    'then add the index to the index collection.
    Set idxCity = .CreateIndex("City")
    With idxCity
        .Fields.Append .CreateField("City")
        .Fields.Append .CreateField("LastName")
    End With
    .Indexes.Append idxCity
   
    'Create another index based on the ZipCode field.
    Set idxZipCode = .CreateIndex
    With idxZipCode
        .Name = "ZipCode"
        .Fields.Append .CreateField("ZipCode")
        .Fields.Append .CreateField("LastName")
    End With
    .Indexes.Append idxZipCode
'Refresh the indexes collection.
.Indexes.Refresh
End With
End Sub
Code example 9-8
Public Sub DeleteIndex()
Dim dbsDFG As Database
Dim tdfVols As TableDef
Dim idxCity As Index, idxZipCode As Index

Set dbsDFG = CurrentDb
Set tdfVols = dbsDFG!SrVols
With tdfVols
    .Indexes.Delete ("City")
End With
End Sub
Code example 9-9
' Set the IgnoreNulls property of the City Index object
' based on the user's input.
Select Case MsgBox("Do you want to set IgnoreNulls to True?", _
       vbYesNoCancel)
    Case vbYes
       idxCity.IgnoreNulls = True
    Case vbNo
       idxCity.IgnoreNulls = False
    Case Else
       dbsDFG.Close
    End
End Select
Code example 9-10
Private Sub Archive_Click()
'Archives inactive Applicant Data to ArchiveAppl Data table
Dim strSQLArchive As String, strSQLDelete As String
Dim intChoice As Integer

intChoice = MsgBox("Do you want to archive inactive data now? ", _
    vbYesNo + vbQuestion, "Archive?")
If intChoice = 7 Then     'If not Yes, exit procedure.
    GoTo Exit_Archive_Click
Else
    strSQLArchive = "INSERT INTO [ArchiveAppl Data]" & _
        "SELECT [Applicant Data].* FROM [Applicant Data]" & _
        "WHERE (([Applicant Data].[Deceased?]) = True) " & _
        "OR (([Applicant Data].[Moved Out State]) = True) " & _
        "OR (([Applicant Data].[Returned-Not want]) = True);"
    DoCmd.RunSQL (strSQLArchive)

'Delete the same records from the Applicant Data table.
strSQLDelete = "DELETE [Applicant Data].* _
 "FROM [Applicant Data]" & _
        "WHERE (([Applicant Data].[Deceased?]) = True) " & _
        "OR (([Applicant Data].[Moved Out State]) = True) " & _
        "OR (([Applicant Data].[Returned-Not want]) = True);"
    DoCmd.RunSQL (strSQLDelete)
End If

Exit_Archive_Click:
    Exit Sub
End Sub
Code example 9-11
Private Sub Go_Click()
'This procedure creates a list of e-mail addresses for readers of
'selected material.
Dim strSQLE-mail As String, strEmptyT As String
strEmptyT = "DELETE [E-mail List].* FROM [E-mail List];"
DoCmd.SetWarnings False
DoCmd.RunSQL strEmptyT

If SDUT = True Then        'Material is SD Union
   strSQLE-mail = "INSERT INTO [E-mail List] ( [Last Name], " &  _
 "[First Name], e-mail, Material, SchedDay )" & _
        "SELECT Volunteers.[Last Name], " & _
 "Volunteers.[First Name], Volunteers.e-mail, " & _  
 "Schedule.Material, Schedule.SchedDay " & _
        "FROM Volunteers INNER JOIN Schedule " & _
        "ON (Volunteers.[First Name] = Schedule.[First Name]) " & _
        "AND (Volunteers.[Last Name] = Schedule.[Last Name]) " & _
        "WHERE (((Volunteers.e-mail) Is Not Null) AND " & _
        "((Schedule.Material) Like 'SD Union*'));"
    DoCmd.RunSQL strSQLE-mail
End If

If LAT = True Then          'Material is LA Times
strSQLE-mail = "INSERT INTO [E-mail List] ( [Last Name], " & _  
    "[First Name], e-mail, Material, SchedDay )" & _
        "SELECT Volunteers.[Last Name], " & _
 "Volunteers.[First Name], Volunteers.e-mail, " & _ 
 "Schedule.Material, Schedule.SchedDay " & _
        "FROM Volunteers INNER JOIN Schedule " & _
        "ON (Volunteers.[First Name] = Schedule.[First Name]) " & _
        "AND (Volunteers.[Last Name] = Schedule.[Last Name]) " & _
        "WHERE (((Volunteers.e-mail) Is Not Null) AND " & _
        "((Schedule.Material) Like 'Los Angeles*'));"
     DoCmd.RunSQL strSQLE-mail
End If

If Books = True Then          'Material is books
strSQLE-mail = "INSERT INTO [E-mail List] ( [Last Name], " & _  
    "[First Name], e-mail, Material, SchedDay )" & _
        "SELECT Volunteers.[Last Name], " & _
 "Volunteers.[First Name], Volunteers.e-mail, " & _ 
 "Schedule.Material, Schedule.SchedDay " & _
        "FROM Volunteers INNER JOIN Schedule " & _
        "ON (Volunteers.[First Name] = Schedule.[First Name]) " & _
        "AND (Volunteers.[Last Name] = Schedule.[Last Name]) " & _
        "WHERE (((Volunteers.e-mail) Is Not Null) AND " & _
        "((Schedule.Material) Like 'Books'));"
     DoCmd.RunSQL strSQLE-mail
End If

If Other = True Then          'Any other material
strSQLE-mail = "INSERT INTO [E-mail List] ( [Last Name], " & _  
    "[First Name], e-mail, Material, SchedDay )" & _
        "SELECT Volunteers.[Last Name], " & _
 "Volunteers.[First Name], Volunteers.e-mail, " & _ 
 "Schedule.Material, Schedule.SchedDay " & _
        "FROM Volunteers INNER JOIN Schedule " & _
        "ON (Volunteers.[First Name] = Schedule.[First Name]) " & _
        "AND (Volunteers.[Last Name] = Schedule.[Last Name]) " & _
        "WHERE (((Volunteers.e-mail) Is Not Null) AND " & _
        "((Schedule.Material) Like 'Other'));"
     DoCmd.RunSQL strSQLE-mail
End If
DoCmd.SetWarnings True
DoCmd.Close
End Sub
Code example 9-12
Private Sub Form_Open(Cancel As Integer)
'This procedure sets the validation rule and text for the
'Age text box control in the Volunteers form.
Dim strRule As String, strText As String

strRule = ">=50"
strText = "You must be 50 or over to be a senior volunteer"

Me!Age.ValidationRule = strRule
Me!Age.ValidationText = strText

End Sub
Code example 9-13
Public Sub ValidAge()
Dim dbs As Database, tdf As TableDef
Dim fld As Field

Set dbs = CurrentDb
Set tdf = dbs.TableDefs("SrVols")
Set fld = tdf.Fields("Age")
fld.ValidationRule = ">=50"
fld.ValidationText = "Senior Vols must be at least 50"
End Sub
Code example 9-14
Private Sub OpenForm_Click()
'This procedure prompts the user for the volunteer's last name
'then filters the records that appear in the DAR form.
    Dim strDocName As String
    Dim strFilter As String, strName As String

    strName = InputBox("Enter Sr Vol last Name", "Last Name")
    strFilter = "LastName = " & "'" & strName & "'"
    strDocName = "DARs"
    DoCmd.OpenForm strDocName, , , strFilter

End Sub
Code example 9-15
Private Sub OpenForm_Click()
'This procedure opens the DARs form and filters
'for DARs from Senior Volunteer Elliott.
    Dim strDocName As String
    Dim strFilter As String
   
    strDocName = "DARs"
    strfilter = "LastName = 'Elliott'"
    DoCmd.OpenForm strDocName, , , strFilter
End Sub
Code example 9-16
Private Sub Form_BeforeUpdate(Cancel As Integer)
'If the record includes an address, look for the ZipCode.

If Not IsNull(Address) And IsNull(ZipCode) Then
    MsgBox "Please enter the ZipCode", vbExclamation
    ZipCode.SetFocus        'Return to the ZipCode control
    Cancel = True           'Cancel saving the record
End If
End Sub
Code example 9-17
Private Sub Form_Load()
'This procedure adds input masks to the Phone and Zipcode fields.
Forms![SrVols Special]!Phone.InputMask = "(###) ###-####"
Forms![SrVols Special]!ZipCode.InputMask = "00000-9999"
End Sub
Code example 9-18
Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)
'If the Important Info field is blank, don't show the label.

Dim blnInfo As Boolean
'Check for blank Info field.
blnInfo = Not IsNull(Important_Info)
'Set the Visible property for the label
Label3.Visible = blnInfo

End Sub
Code example 9-19
Private Sub Report_Open(Cancel As Integer)
'This procedure filters the labels by state, if desired.
Dim strState As String
Dim strFilter As String
'Prompts for state abbreviation
strState = InputBox("Enter 2-character state code, e.g. CA")

'If no state entered, shows all labels.
If strState = "" Then
    DoCmd.OpenReport "Labels Volunteers", acViewPreview
Else
    strFilter = "[State] = """ & strState & """"
    DoCmd.OpenReport "Labels Volunteers", acViewPreview, , strFilter
End If
End Sub
Code example 9-20
Private Sub ReportHeader_Format(Cancel As Integer, FormatCount As Integer)
Dim rpt As Report
Dim strTitle As String
Dim intHSize As Integer, intVSize As Integer
Set rpt = Me
strTitle = "Senior Volunteers - 2003"
'Set the report scale to pixels and the font properties.  
With rpt
    .ScaleMode = 3
    .FontName = "Courier"
    .FontSize = 24
    .FontBold = True
End With
'Compute the height and width of the text.
intVSize = rpt.TextHeight(strTitle)
intHSize = rpt.TextWidth(strTitle)

'Compute the location for the text.
rpt.CurrentX = (rpt.ScaleWidth / 2) - (intHSize / 2)
rpt.CurrentY = (rpt.ScaleHeight / 3) - (intVSize / 2)
'Print the title.
rpt.Print strTitle
End Sub
Code example 9-21
Sub LookFor()
'Start the error handler
On Error GoTo Error_LookFor
    [statements that may cause an error]
Exit_LookFor:
    Exit Sub
Error_LookFor:
    [error handing code]
    Resume Exit_LookFor
End Sub
Code example 9-22
Public Sub DelRecord(strName As String)
On Error GoTo DelRecordErr:
Dim strSQL As String

'This procedure deletes records from a table where the
'last name equals the argument passed by the user.
strSQL = "Delete * FROM Volunteers Where " & _
         "LastName = '" & strLName & "'"

DoCmd.RunSQL strSQL
'A warning message is displayed.
'If the user cancels the action, error # 2501 occurs.
Exit_DelRecord:
    Exit Sub
DelRecordErr:
    If Err.Number = 0 Then
        Exit Function
    ElseIf Err.Number = 2501 Then
MsgBox "The delete action was canceled by the user.", vbInformation, "Delete Action"
    Else
 MsgBox Err.Number & ": " & Err.Description, vbCritical, "Delete Action"
    End If
    Resume Exit_DelRecord
End Sub
Code example 9-23
Public Sub CheckDateFormat()
On Error GoTo CheckDateFormatErr
Dim intNumberToInsert As Integer
Const conDataMismatch As Integer = 13
Const errErrThisIsATest = "The value entered was not a valid " _
        & " number."
intNumberToInsert = InputBox("Enter a number to insert.", _
"Date Input Example")
Exit_CheckDateFormat:
Exit Sub

CheckDateFormatErr:
If Err = 0 Then
Exit Sub
       ElseIf Err = 13 Then
       ' Regenerate original error.
       	Dim intErrNum As Integer
       	intErrNum = Err
       	Err.Clear
       	Err.Raise intErrNum + 514, , errErrThisIsATest
    Else
        ErrRaiseErr.Number, , Err.Description
End If
Resume Exit_CheckDateFormat
End Sub

Access Power Programming with VBA, 8/23/2003, Web code examples
Virginia Andersen


